home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
forth
/
amiga
/
amigaker.arc
/
19.extend
< prev
next >
Wrap
Text File
|
1987-12-30
|
14KB
|
387 lines
;
; 19.extend
;
; extend the system
* depth (s -- n ) Returns the number of parameters on the stack.
dc.w -1
dc.l link0
link0 set *-4
dc.b $85,'dept',$80!'h'
cnop 0,2
_depth dc.l nest
dc.l _sp_fetch,_sp0,_fetch,_swap,_minus
dc.l _4,_divide,_exit
* .s (s -- ) Displays contents of the parameter stack
dc.w -1
dc.l link2
link2 set *-4
dc.b $82,'.',$80!'s'
cnop 0,2
_dot_s dc.l nest
dc.l _depth,_question_dup,_question_branch,3$
dc.l _0,_nest_do,2$
1$ dc.l _depth,_i,_minus,_1_minus,_pick
dc.l _nest_lit,10,_u_dot_r,_space
dc.l _key_question,_nest_question_leave
dc.l _nest_loop,1$
2$ dc.l _branch,4$
3$ dc.l _nest_dot_quote
dc.b 7,'Empty ',0
cnop 0,2
4$ dc.l _exit
* (.id) (s addr len -- addr' len ) Moves the id to stdbuffer
; and pads it with underlines.
dc.w -1
dc.l link0
link0 set *-4
dc.b $85,'(.id',$80!')'
cnop 0,2
_nest_dot_id dc.l *+4
move.l (sp),d0 ;get length
beq.s 4$ ;exit if it's null
subq #1,d0 ;adjust for the loop
lea stdbuffer,a0 ;destination
move.l 4(sp),a1 ;source
move.l a0,4(sp) ; alter string addr
1$ move.b (a1)+,(a0)+ ;move name
dbmi d0,1$ ; until high bit or 31 max.
subq.l #1,a0 ;point to last char
moveq #127,d1 ;mask
and.b d1,(a0)+ ; of high bit
moveq #'_',d1 ;set underline character
addq.b #1,d0 ;adjust for loop
bra.s 3$
2$ move.b d1,(a0)+ ;pad with underscore
3$ dbra d0,2$
4$ jmp (a3)
* .id (s nfa -- ) Prints the name of the word on the terminal.
dc.w -1
dc.l link2
link2 set *-4
dc.b $83,'.i',$80!'d'
cnop 0,2
_dot_id dc.l nest
dc.l _count,_nest_lit,31,_and
dc.l _nest_dot_id,_type,_space,_exit
* c/l Constant, starts out at 79 for a full screen. If resized,
; windowstatus can update the sizes
dc.w -1
dc.l link3
link3 set *-4
dc.b $83,'c/',$80!'l'
cnop 0,2
_c_per_l dc.l doconstant,79
* l/scr Constant, 22 lines at the start. Resizing will alter it.
dc.w -1
dc.l link0
link0 set *-4
dc.b $85,'l/sc',$80!'r'
cnop 0,2
_l_per_scr dc.l doconstant,22
* \ Comment character, ignores the rest of the line.
dc.w -1
dc.l link0
link0 set *-4
dc.b $81!immediate,$80!'\'
cnop 0,2
_Skip dc.l nest
dc.l _end_question,_on,_exit
* (s Synonym for (, used as stack comments.
dc.w -1
dc.l link0
link0 set *-4
dc.b $82!immediate,'(',$80!'s'
cnop 0,2
_paren_s dc.l nest
dc.l _paren
dc.l _exit
* ? (s addr -- ) Prints contents of the cell at addr.
dc.w -1
dc.l link3
link3 set *-4
dc.b $81,$80!'?'
cnop 0,2
dc.l nest
dc.l _fetch,_dot,_exit
* ?enough (S n -- ) Issues an error message if too few parameters
; are on the parameter stack.
dc.w -1
dc.l link3
link3 set *-4
dc.b $87,'?enoug',$80!'h'
cnop 0,2
_question_enough dc.l nest
dc.l _depth,_1_minus,_greater_than
dc.l _nest_abort_quote
dc.b 22,'Not enough Parameters',0
cnop 0,2
dc.l _exit
; root vocabulary, only and also concept
rootlink0 set 0
rootlink1 set 0
rootlink2 set 0
rootlink3 set 0
* root Vocabulary root
dc.w -1
dc.l link2
link2 set *-4
dc.b $84,'roo',$80!'t'
cnop 0,2
_root dc.l vocabulary_does
dc.l rootLink0,rootLink1,rootLink2,rootLink3
dc.l voc_link
voc_link set *-4
* also (s -- )
dc.w -1
dc.l rootlink1
rootlink1 set *-4
dc.b $84,'als',$80!'o'
cnop 0,2
dc.l nest
dc.l _context,_dup,_4_plus,_number_vocs
dc.l _2_minus,_4_times,_cmove_up,_exit
* only (s -- )
dc.w -1
dc.l rootlink3
rootlink3 set *-4
dc.b $84,'onl',$80!'y'
cnop 0,2
dc.l nest
dc.l _nest_lit,_root,_to_body,_context
dc.l _number_vocs,_1_minus,_4_times
dc.l _2dup,_erase,_plus,_store,_root,_exit
* previous (s -- )
dc.w -1
dc.l rootlink0
rootlink0 set *-4
dc.b $88,'previou',$80!'s'
cnop 0,2
dc.l nest
dc.l _context,_dup,_4_plus,_swap,_number_vocs
dc.l _2_minus,_4_times,_cmove
dc.l _context,_number_vocs,_2_minus,_4_times
dc.l _plus,_off,_exit
* forth
dc.w -1
dc.l rootlink2
rootlink2 set *-4
dc.b $85,'fort',$80!'h'
cnop 0,2
dc.l nest
dc.l _forth,_exit
* definitions
dc.w -1
dc.l rootlink0
rootlink0 set *-4
dc.b $8B,'definition',$80!'s'
cnop 0,2
dc.l nest
dc.l _definitions,_exit
* order
dc.w -1
dc.l rootlink3
rootlink3 set *-4
dc.b $85,'orde',$80!'r'
cnop 0,2
dc.l nest
dc.l _cr,_nest_dot_quote
dc.b 10,'Context: ',0
cnop 0,2
dc.l _context,_number_vocs,_0,_nest_do,3$
1$ dc.l _dup,_fetch,_question_dup,_question_branch,2$
dc.l _body_from,_to_name,_dot_id
2$ dc.l _4_plus,_nest_loop,1$
3$ dc.l _drop
dc.l _cr,_nest_dot_quote
dc.b 10,'Current: ',0
cnop 0,2
dc.l _current,_fetch,_body_from,_to_name
dc.l _dot_id,_exit
* vocs
dc.w -1
dc.l rootlink2
rootlink2 set *-4
dc.b $84,'voc',$80!'s'
cnop 0,2
dc.l nest
dc.l _voc_link
1$ dc.l _fetch,_question_dup,_question_branch,2$
dc.l _dup,_number_threads,_4_times,_minus
dc.l _body_from,_to_name,_dot_id,_branch,1$
2$ dc.l _exit
; additional comparisons
* u<=
dc.w -1
dc.l link1
link1 set *-4
dc.b $83,'u<',$80!'='
cnop 0,2
dc.l nest
dc.l _u_greater,_not,_exit
* u>=
dc.w -1
dc.l link1
link1 set *-4
dc.b $83,'u>',$80!'='
cnop 0,2
dc.l nest
dc.l _u_less,_not,_exit
* <=
dc.w -1
dc.l link0
link0 set *-4
dc.b $82,'<',$80!'='
cnop 0,2
dc.l nest
dc.l _greater_than,_not,_exit
* >=
dc.w -1
dc.l link2
link2 set *-4
dc.b $82,'>',$80!'='
cnop 0,2
dc.l nest
dc.l _less_than,_not,_exit
* 0<=
dc.w -1
dc.l link0
link0 set *-4
dc.b $83,'0<',$80!'='
cnop 0,2
dc.l nest
dc.l _0_greater,_not,_exit
* 0>=
dc.w -1
dc.l link0
link0 set *-4
dc.b $83,'0>',$80!'='
cnop 0,2
dc.l nest
dc.l _0_less,_not,_exit
; display words in the dictionary
* ?line
dc.w -1
dc.l link3
link3 set *-4
dc.b $85,'?lin',$80!'e'
cnop 0,2
_question_line dc.l nest
dc.l _number_out,_fetch,_plus
dc.l _c_per_l,_8_minus,_greater_than
dc.l _question_branch,1$
dc.l _cr
1$ dc.l _exit
* largest (s addr n -- addr' val )
dc.w -1
dc.l link0
link0 set *-4
dc.b $87,'larges',$80!'t'
cnop 0,2
_largest dc.l nest
dc.l _over,_0,_swap,_rot,_0
dc.l _nest_do,3$
1$ dc.l _2dup,_fetch,_u_less,_question_branch,2$
dc.l _minus_rot,_2drop,_dup,_fetch,_over
2$ dc.l _4_plus,_nest_loop,1$
3$ dc.l _drop,_exit
* words
dc.w -1
dc.l link3
link3 set *-4
dc.b $85,'word',$80!'s'
cnop 0,2
_words dc.l nest
dc.l _cr,_context,_fetch,_here,_number_threads
dc.l _4_times,_cmove
1$ dc.l _here,_number_threads,_largest,_dup
dc.l _question_branch,3$
dc.l _dup,_l_to_name,_dup,_c_fetch,_nest_lit,31
dc.l _and,_question_line,_dot_id,_space,_space
dc.l _fetch,_swap,_store,_key_question
dc.l _question_branch,2$
dc.l _exit
2$ dc.l _branch,1$
3$ dc.l _2drop,_exit
* words ( for the root vocabulary )
dc.w -1
dc.l rootlink3
rootlink3 set *-4
dc.b $85,'word',$80!'s'
cnop 0,2
dc.l nest
dc.l _words,_exit
; two words to show the linked lists, one for files and one for libraries.
* files
dc.w -1
dc.l link2
link2 set *-4
dc.b $85,'file',$80!'s'
cnop 0,2
dc.l nest
dc.l _cr,_file_link
1$ dc.l _fetch,_question_dup,_question_branch,4$
dc.l _dup,_4_plus,_count,_type
dc.l _dup,_nest_lit,18,_minus,_fetch
dc.l _question_branch,2$
dc.l _nest_dot_quote
dc.b 8,' (open)',0
cnop 0,2
dc.l _branch,3$
2$ dc.l _nest_dot_quote
dc.b 10,' (closed)',0
cnop 0,2
3$ dc.l _cr,_branch,1$
4$ dc.l _exit
* libs
dc.w -1
dc.l link0
link0 set *-4
dc.b $84,'lib',$80!'s'
cnop 0,2
dc.l nest
dc.l _cr,_lib_link
1$ dc.l _fetch,_question_dup,_question_branch,2$
dc.l _dup,_8_minus,_to_name,_dot_id,_cr
dc.l _branch,1$
2$ dc.l _exit
